home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / symbol.c < prev    next >
C/C++ Source or Header  |  1992-10-11  |  5KB  |  247 lines
  1. #include <ctype.h>
  2.  
  3. #include "scheme.h"
  4.  
  5. Object Obarray;
  6.  
  7. Object Null,
  8.        True,
  9.        False,
  10.        Unbound,
  11.        Special,
  12.        Void,
  13.        Newline,
  14.        Eof,
  15.        Zero,
  16.        One;
  17.  
  18. Init_Symbol () {
  19.     SETTYPE(Null, T_Null);
  20.     SETTYPE(True, T_Boolean); SETFIXNUM(True, 1);
  21.     SETTYPE(False, T_Boolean); SETFIXNUM(False, 0);
  22.     SETTYPE(Unbound, T_Unbound);
  23.     SETTYPE(Special, T_Special);
  24.     SETTYPE(Void, T_Void);
  25.     SETTYPE(Eof, T_End_Of_File);
  26.     Newline = Make_Char ('\n');
  27.     Zero = Make_Fixnum (0);
  28.     One = Make_Fixnum (1);
  29.     Obarray = Make_Vector (OBARRAY_SIZE, Null);
  30.     Global_GC_Link (Obarray);
  31. }
  32.  
  33. Object Make_Symbol (name) Object name; {
  34.     Object sym;
  35.     register struct S_Symbol *sp;
  36.     GC_Node;
  37.  
  38.     GC_Link (name);
  39.     sym = Alloc_Object (sizeof (struct S_Symbol), T_Symbol, 0);
  40.     sp = SYMBOL(sym);
  41.     sp->name = name;
  42.     sp->value = Unbound;
  43.     sp->plist = Null;
  44.     GC_Unlink;
  45.     return sym;
  46. }
  47.  
  48. Object P_Symbolp (x) Object x; {
  49.     return TYPE(x) == T_Symbol ? True : False;
  50. }
  51.  
  52. Object P_Symbol_To_String (x) Object x; {
  53.     Check_Type (x, T_Symbol);
  54.     return SYMBOL(x)->name;
  55. }
  56.  
  57. Object Obarray_Lookup (str, len) register char *str; register len; {
  58.     register h;
  59.     register struct S_String *s;
  60.     register struct S_Symbol *sym;
  61.     Object p;
  62.  
  63.     h = Hash (str, len) % OBARRAY_SIZE;
  64.     for (p = VECTOR(Obarray)->data[h]; !Nullp (p); p = sym->next) {
  65.     sym = SYMBOL(p);
  66.     s = STRING(sym->name);
  67.     if (s->size == len && bcmp (s->data, str, len) == 0)
  68.         return p;
  69.     }
  70.     return Make_Fixnum (h);
  71. }
  72.  
  73. Object CI_Intern (str) char *str; {
  74.     Object s, *p, sym, ostr;
  75.     register len;
  76.     register char *src;
  77.     char *dst;
  78.     char buf[128];
  79.     Alloca_Begin;
  80.  
  81.     len = strlen (str);
  82.     if (len > sizeof(buf)) {
  83.     Alloca (dst, char*, len);
  84.     } else 
  85.     dst = buf;
  86.     src = str;
  87.     str = dst;
  88.     for ( ; *src; src++, dst++)
  89.     *dst = isupper (*src) ? tolower (*src) : *src;
  90.     s = Obarray_Lookup (str, len);
  91.     if (TYPE(s) != T_Fixnum) {
  92.     Alloca_End;
  93.     return s;
  94.     }
  95.     ostr = Make_Const_String (str, len);
  96.     sym = Make_Symbol (ostr);
  97.     p = &VECTOR(Obarray)->data[FIXNUM(s)];
  98.     SYMBOL(sym)->next = *p;
  99.     Alloca_End;
  100.     return *p = sym;
  101. }
  102.  
  103. Object Intern (str) char *str; {
  104.     Object s, *p, sym, ostr;
  105.     register len;
  106.  
  107.     if (Case_Insensitive)
  108.     return CI_Intern (str);
  109.     len = strlen (str);
  110.     s = Obarray_Lookup (str, len);
  111.     if (TYPE(s) != T_Fixnum)
  112.     return s;
  113.     ostr = Make_Const_String (str, len);
  114.     sym = Make_Symbol (ostr);
  115.     p = &VECTOR(Obarray)->data[FIXNUM(s)];
  116.     SYMBOL(sym)->next = *p;
  117.     return *p = sym;
  118. }
  119.  
  120. Object P_String_To_Symbol (str) Object str; {
  121.     Object s, *p, sym;
  122.  
  123.     Check_Type (str, T_String);
  124.     s = Obarray_Lookup (STRING(str)->data, STRING(str)->size);
  125.     if (TYPE(s) != T_Fixnum)
  126.     return s;
  127.     str = Make_String (STRING(str)->data, STRING(str)->size);
  128.     sym = Make_Symbol (str);
  129.     p = &VECTOR(Obarray)->data[FIXNUM(s)];
  130.     SYMBOL(sym)->next = *p;
  131.     return *p = sym;
  132. }
  133.  
  134. Object P_Oblist () {
  135.     register i;
  136.     Object p, list, bucket;
  137.     GC_Node2;
  138.  
  139.     p = list = Null;
  140.     GC_Link2 (p, list);
  141.     for (i = 0; i < OBARRAY_SIZE; i++) {
  142.     bucket = Null;
  143.     for (p = VECTOR(Obarray)->data[i]; !Nullp (p); p = SYMBOL(p)->next)
  144.         bucket = Cons (p, bucket);
  145.     if (!Nullp (bucket))
  146.         list = Cons (bucket, list);
  147.     }
  148.     GC_Unlink;
  149.     return list;
  150. }
  151.  
  152. Object P_Put (argc, argv) Object *argv; {
  153.     Object sym, key, last, tail, prop;
  154.     GC_Node3;
  155.  
  156.     sym = argv[0];
  157.     key = argv[1];
  158.     Check_Type (sym, T_Symbol);
  159.     Check_Type (key, T_Symbol);
  160.     last = Null;
  161.     for (tail = SYMBOL(sym)->plist; !Nullp (tail); tail = Cdr (tail)) {
  162.     prop = Car (tail);
  163.     if (EQ(Car (prop), key)) {
  164.         if (argc == 3)
  165.         Cdr (prop) = argv[2];
  166.         else if (Nullp (last))
  167.         SYMBOL(sym)->plist = Cdr (tail);
  168.         else
  169.         Cdr (last) = Cdr (tail);
  170.         return key;
  171.     }
  172.     last = tail;
  173.     }
  174.     if (argc == 2)
  175.     return False;
  176.     GC_Link3 (sym, last, key);
  177.     tail = Cons (key, argv[2]);
  178.     tail = Cons (tail, Null);
  179.     if (Nullp (last))
  180.     SYMBOL(sym)->plist = tail;
  181.     else
  182.     Cdr (last) = tail;
  183.     GC_Unlink;
  184.     return key;
  185. }
  186.  
  187. Object P_Get (sym, key) Object sym, key; {
  188.     Object prop;
  189.  
  190.     Check_Type (sym, T_Symbol);
  191.     Check_Type (key, T_Symbol);
  192.     prop = Assq (key, SYMBOL(sym)->plist);
  193.     if (!Truep (prop))
  194.     return False;
  195.     /*
  196.      * Do we want to signal an error or return #f?
  197.      *
  198.      * Primitive_Error ("~s has no such property: ~s", sym, key);
  199.      */
  200.     return Cdr (prop);
  201. }
  202.  
  203. Object P_Symbol_Plist (sym) Object sym; {
  204.     Check_Type (sym, T_Symbol);
  205.     return Copy_List (SYMBOL(sym)->plist);
  206. }
  207.  
  208. Hash (str, len) char *str; {
  209.     register h;
  210.     register char *p, *ep;
  211.  
  212.     h = 5 * len;
  213.     if (len > 5)
  214.     len = 5;
  215.     for (p = str, ep = p+len; p < ep; ++p)
  216.     h = (h << 2) ^ *p;
  217.     return h & 017777777777;
  218. }
  219.  
  220. Define_Symbol (sym, name) Object *sym; char *name; {
  221.     *sym = Intern (name);
  222.     Func_Global_GC_Link (sym);
  223. }
  224.  
  225. void Define_Variable (var, name, init) Object *var, init; char *name; {
  226.     Object frame, sym;
  227.     GC_Node;
  228.  
  229.     GC_Link (init);
  230.     sym = Intern (name);
  231.     SYMBOL(sym)->value = init;
  232.     frame = Add_Binding (Car (The_Environment), sym, init);
  233.     *var = Car (frame);
  234.     Car (The_Environment) = frame;
  235.     Func_Global_GC_Link (var);
  236.     GC_Unlink;
  237. }
  238.  
  239. Object Var_Get (var) Object var; {
  240.     return Cdr (var);
  241. }
  242.  
  243. void Var_Set (var, val) Object var, val; {
  244.     Cdr (var) = val;
  245.     SYMBOL (Car (var))->value = val;
  246. }
  247.